home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 050 / madtrb31.arc / GRAPH.PAS < prev    next >
Pascal/Delphi Source File  |  1985-05-15  |  3KB  |  86 lines
  1. Program Graphics;         { Author: William P. Smith  }
  2.                           {         Mitchellville, Md }
  3.                           { This program generates a 3-D surface for the }
  4.                           { function Z=z(X,Y).                           }
  5. Const
  6.       Thx = 0.2;      {rotation }
  7.       Thy = 0.2;      { angle   }
  8.         n = 20;       {# lines for detail -- 20 best for testing surfaces }
  9.                       {                      50 for final picture         }
  10. Type
  11.       GraphFileName = String[15];
  12.  
  13. Var
  14.     cx,cy,sx,sy,delxp,delyp,xl,xu,yl,yu,dyp,dxp,
  15.     fx,fy,xp1,xp2,yp1,yp2,z1,z2,x,y,xp,yp: real;
  16.     i,j,xplot1,yplot1,xplot2,yplot2: integer;
  17.     q: char;
  18.     Ymax,Ymin: array[0..639] of integer;  {for hidden line remover}
  19.     name: GraphFileName;                  {graph will be saved under name.pic}
  20.     scrnfil: file;
  21.     Buffer: Array[1..$4000] of Byte;
  22.     Video: Byte Absolute $B800:0000;
  23.  
  24. function z(x,y:real): real;              { equation for surface }
  25. var s:real;
  26. begin
  27.   s:=sqr(x)+sqr(y);                      { this surface was used   }
  28.   z:=cos(2*s)*exp(-0.5*s)                { produce cosexp.pic      }
  29. end;
  30.  
  31. procedure GetGraph;
  32. begin
  33.   cx:=cos(thx); cy:=cos(thy);
  34.   sx:=sin(thx); sy:=sin(thy);
  35.   write('x-range ');readln(xp1,xp2);        { try -3 3                    }
  36.   write('y-range ');readln(yp1,yp2);        {     -3 3                    }
  37.   write('z-range ');readln(z1,z2);          {      0 1  for above example }
  38.   delxp:=(xp2-xp1)/n; delyp:=(yp2-yp1)/n;
  39.   xl:=0.0; xu:=(xp2-xp1)*cx+(yp2-yp1)*cy;
  40.   yl:=-(xp2-xp1)*sx; yu:=(yp2-yp1)*sy+z2-z1;
  41.   fx:=640/xu; fy:=200/(yu-yl);
  42.   hires; hirescolor(15);                    { set color -- white is used here }
  43.   for i:=0 to 639 do begin
  44.     ymax[i]:=199;                           { initialize hidden line remover }
  45.     ymin[i]:=0;
  46.   end;
  47.   for i:=0 to n do begin
  48.     yp:=yp1+i*delyp; dyp:=yp-yp1;           { project surface onto 640x200 }
  49.     x:=dyp*cy; y:=dyp*sy+z(xp1,yp)-z1;      {  pixel display.}
  50.     xplot1:=round(x*fx);
  51.     yplot1:=200-round((y-yl)*fy);
  52.     for j:=1 to 3*n do begin
  53.       xp:=xp1+j*delxp/3.0; dxp:=xp-xp1;
  54.       x:=dxp*cx+dyp*cy;
  55.       y:=-dxp*sx+dyp*sy+z(xp,yp)-z1;
  56.       xplot2:=round(x*fx);
  57.       yplot2:=200-round((y-yl)*fy);
  58.       if ymax[xplot2]>=yplot2 then begin        { Plot and remove hidden lines}
  59.         ymax[xplot2]:=yplot2;                   {              "              }
  60.         draw(xplot1,yplot1,xplot2,yplot2,1);    {              "              }
  61.       end;                                      {              "              }
  62.       if ymin[xplot2]<=yplot2 then begin        {              "              }
  63.         ymin[xplot2]:=yplot2;                   {              "              }
  64.         draw(xplot1,yplot1,xplot2,yplot2,1);    {              "              }
  65.       end;                                      {              "              }
  66.       xplot1:=xplot2; yplot1:=yplot2;           {              "              }
  67.     end;
  68.   end;
  69. end;
  70.  
  71. procedure GrafSave(name: GraphFileName);       { Save Graph }
  72. var   i: integer;
  73. begin
  74.   rewrite(scrnfil);
  75.   move(Video,Buffer,$4000);
  76.   Blockwrite(Scrnfil,Buffer,128);
  77.   close(scrnfil);
  78.   repeat until keypressed;
  79.   textmode(2);
  80. end;
  81. begin
  82.   write('Name for Graphics File? '); readln(name);
  83.   assign(scrnfil,name+'.pic');
  84.   GetGraph;
  85.   GrafSave(name);
  86. end.